ONCOCOP.m

ONCOCOP ;WASH ISC/SRR,MLH-COMPUTED FIELDS FOR 165.5, DIRECT TO VARPRT ;8/9/93  09:49

 ;;2.2;ONCOLOGY;**1**;Jul 31, 2013;Build 8

 ;

GETPT ;GET POINTERS

 S X=$P($G(^ONCO(165.5,D0,0)),U,2),X=$P($G(^ONCO(160,+X,0)),U) Q:X=""  S DFN=$P(X,";"),OVR="^"_$P(X,";",2)_DFN_","

 Q

 ;

PID ;PATIENT ID (FIRST DIGIT LAST NAME,PLUS LAST 4 SSN

 D GETPT G EX:X="" S OVR=OVR_"0)",PD0=@OVR,X=$E($P(PD0,U),1)_$E($P(PD0,U,9),6,9) G EX

 Q

STCT ;STATE-COUNTY FROM MAS DATA

 D GETPT G EX:X="" S OVR=OVR_".11)",O11=$G(@OVR),(OS,X)=$P(O11,U,5) G EX:X="" S (OC,X)=$P(O11,U,7) G EX:X="" S (OC,X)=$P($G(^DIC(5,OS,1,OC,0)),U) G EX:X="" S X=$P(^DIC(5,OS,0),U,2) G EX:X="" S X=X_"/"_OC G EX

 W !,"CTY=",X ;S OC=X$P($G(^DIC(5,OS,0)),U,2) G EX:X="",EX:$P(O11,U,7)="" S OCT=$O

EX ;EXIT

 K DFN,OVR,OAD

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---ONCOCOP   784     printed  Apr 09, 2024@21:26:13                                                                                                                                                                                                      Page 2

ONCOCOP   ;WASH ISC/SRR,MLH-COMPUTED FIELDS FOR 165.5, DIRECT TO VARPRT ;8/9/93  09:49

 +1       ;;2.2;ONCOLOGY;**1**;Jul 31, 2013;Build 8

 +2       ;

GETPT     ;GET POINTERS

 +1        SET X=$PIECE($GET(^ONCO(165.5,D0,0)),U,2)

           SET X=$PIECE($GET(^ONCO(160,+X,0)),U)

           if X=""

               QUIT 

           SET DFN=$PIECE(X,";")

           SET OVR="^"_$PIECE(X,";",2)_DFN_","

 +2        QUIT 

 +3       ;

PID       ;PATIENT ID (FIRST DIGIT LAST NAME,PLUS LAST 4 SSN

 +1        DO GETPT

           if X=""

               GOTO EX

           SET OVR=OVR_"0)"

           SET PD0=@OVR

           SET X=$EXTRACT($PIECE(PD0,U),1)_$EXTRACT($PIECE(PD0,U,9),6,9)

           GOTO EX

 +2        QUIT 

STCT      ;STATE-COUNTY FROM MAS DATA

 +1        DO GETPT

           if X=""

               GOTO EX

           SET OVR=OVR_".11)"

           SET O11=$GET(@OVR)

           SET (OS,X)=$PIECE(O11,U,5)

           if X=""

               GOTO EX

           SET (OC,X)=$PIECE(O11,U,7)

           if X=""

               GOTO EX

           SET (OC,X)=$PIECE($GET(^DIC(5,OS,1,OC,0)),U)

           if X=""

               GOTO EX

           SET X=$PIECE(^DIC(5,OS,0),U,2)

           if X=""

               GOTO EX

           SET X=X_"/"_OC

           GOTO EX

 +2       ;S OC=X$P($G(^DIC(5,OS,0)),U,2) G EX:X="",EX:$P(O11,U,7)="" S OCT=$O

           WRITE !,"CTY=",X

EX        ;EXIT

 +1        KILL DFN,OVR,OAD

 +2        QUIT