- PSUDEM8 ;BIR/DAM - ICD9 Codes for Inpatient PTF Record Extract ;20 DEC 2001
- ;;4.0;PHARMACY BENEFITS MANAGEMENT;**19**;MARCH, 2005;Build 28
- ;
- ;DBIA's
- ; Reference to file 45 supported by DBIA 3511
- ; Reference to file 80 supported by DBIA 10082
- ; Reference to ICDEX supported by DBIA 5747
- ; Reference to ICDXCODE supported by DBIA 5699
- ;
- EN ;EN CALLED FROM PSUDEM7
- D PTFIEN
- Q
- ;
- PTFIEN ;$O through ^XTMP("PSU_"_PSUJOB,"PSUIPV" to get all the PTF IEN's
- ;
- ;S PSUC=0
- S PSUC=0
- F S PSUC=$O(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUC)) Q:'PSUC D
- .D PTF70 ;gather ICD9 data on ^DGPT(D0,70 node
- .D PTFM ;gather ICD9 data on ^DGPT(D0,"M","AC" node
- .D FIN K ^XTMP("PSU_"_PSUJOB,"PSUTMP3")
- .D EN^PSUDEM9 ;gather CPT data on 2 separate ^DGPT nodes
- Q
- ;
- PTF70 ;Find all ICD pointers present on ^DGPT(D0,70 node
- ;drp 2/13/2012 added second line to each line in old block
- ;N PSU1,PSU2,PSU3,PSU4,PSU5,PSU6,PSU7,PSU8,PSU9,PSU10,PSU11
- N PSU1,PSU2,PSU3,PSU4,PSU5,PSU6,PSU7,PSU8,PSU9,PSU10,PSU11,CSYS
- ;
- S PSU1=$P($G(^DGPT(PSUC,70)),U,10) S:PSU1="" PSU1="NULL" ;Ptr 1 PRINCIPAL[10P:80
- S:PSU1'="NULL" CSYS(1)=$$CSI^ICDEX(80,PSU1),PSU1("ICDSYS")=$S(CSYS(1)=1:9,CSYS(1)=30:10,1:"")
- ;
- S PSU2=$P($G(^DGPT(PSUC,70)),U,16) S:PSU2="" PSU2="NULL" ;Ptr 2 SECONDARY[16P:80]
- S:PSU2'="NULL" CSYS(2)=$$CSI^ICDEX(80,PSU2),PSU2("ICDSYS")=$S(CSYS(2)=1:9,CSYS(2)=30:10,1:"")
- ;
- S PSU3=$P($G(^DGPT(PSUC,70)),U,17) S:PSU3="" PSU3="NULL" ;Ptr 3
- S:PSU3'="NULL" CSYS(3)=$$CSI^ICDEX(80,PSU3),PSU3("ICDSYS")=$S(CSYS(3)=1:9,CSYS(3)=30:10,1:"")
- ;
- S PSU4=$P($G(^DGPT(PSUC,70)),U,18) S:PSU4="" PSU4="NULL" ;Ptr 4
- S:PSU4'="NULL" CSYS(4)=$$CSI^ICDEX(80,PSU4),PSU4("ICDSYS")=$S(CSYS(4)=1:9,CSYS(4)=30:10,1:"")
- ;
- S PSU5=$P($G(^DGPT(PSUC,70)),U,19) S:PSU5="" PSU5="NULL" ;Ptr 5
- S:PSU5'="NULL" CSYS(5)=$$CSI^ICDEX(80,PSU5),PSU5("ICDSYS")=$S(CSYS(5)=1:9,CSYS(5)=30:10,1:"")
- ;
- S PSU6=$P($G(^DGPT(PSUC,70)),U,20) S:PSU6="" PSU6="NULL" ;Ptr 6
- S:PSU6'="NULL" CSYS(6)=$$CSI^ICDEX(80,PSU6),PSU6("ICDSYS")=$S(CSYS(6)=1:9,CSYS(6)=30:10,1:"")
- ;
- S PSU7=$P($G(^DGPT(PSUC,70)),U,21) S:PSU7="" PSU7="NULL" ;Ptr 7
- S:PSU7'="NULL" CSYS(7)=$$CSI^ICDEX(80,PSU7),PSU7("ICDSYS")=$S(CSYS(7)=1:9,CSYS(7)=30:10,1:"")
- ;
- S PSU8=$P($G(^DGPT(PSUC,70)),U,22) S:PSU8="" PSU8="NULL" ;Ptr 8
- S:PSU8'="NULL" CSYS(8)=$$CSI^ICDEX(80,PSU8),PSU8("ICDSYS")=$S(CSYS(8)=1:9,CSYS(8)=30:10,1:"")
- ;
- S PSU9=$P($G(^DGPT(PSUC,70)),U,23) S:PSU9="" PSU9="NULL" ;Ptr 9
- S:PSU9'="NULL" CSYS(9)=$$CSI^ICDEX(80,PSU9),PSU9("ICDSYS")=$S(CSYS(9)=1:9,CSYS(9)=30:10,1:"")
- ;
- S PSU10=$P($G(^DGPT(PSUC,70)),U,24) S:PSU10="" PSU10="NULL" ;Ptr 10
- S:PSU10'="NULL" CSYS(10)=$$CSI^ICDEX(80,PSU10),PSU10("ICDSYS")=$S(CSYS(10)=1:9,CSYS(10)=30:10,1:"")
- ;
- S PSU11=$P($G(^DGPT(PSUC,70)),U,11) S:PSU11="" PSU11="NULL" ;Ptr 11 PRINCIPAL DIAGNOSIS pre 1986 [11P:80]
- S:PSU11'="NULL" CSYS(11)=$$CSI^ICDEX(80,PSU11),PSU11("ICDSYS")=$S(CSYS(11)=1:9,CSYS(11)=30:10,1:"")
- D ICD91
- Q
- ;
- ICD91 ;Find ICD codes from pointer on ^DGPT(D0,70 node and place in
- ;an array
- ;
- N PSUID1,PSUID2,PSUID3,PSUID4,PSUID5,PSUID6,PSUID7,PSUID8,PSUID9
- N PSUID10,PSUID11
- S:PSU1'["N" PSUID1=$P($$ICDDATA^ICDXCODE(CSYS(1),PSU1),U,2) D
- .I $D(PSUID1) S ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,1,PSUID1)=$G(PSU1("ICDSYS")) ;1ST ICD CODE
- S:PSU2'["N" PSUID2=$P($$ICDDATA^ICDXCODE(CSYS(2),PSU2),U,2) D
- .I $D(PSUID2) S ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,2,PSUID2)=$G(PSU2("ICDSYS")) ;2ND ICD CODE
- S:PSU3'["N" PSUID3=$P($$ICDDATA^ICDXCODE(CSYS(3),PSU3),U,2) D
- .I $D(PSUID3) S ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,3,PSUID3)=$G(PSU3("ICDSYS")) ;3rd ICD CODE
- S:PSU4'["N" PSUID4=$P($$ICDDATA^ICDXCODE(CSYS(4),PSU4),U,2) D
- .I $D(PSUID4) S ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,4,PSUID4)=$G(PSU4("ICDSYS")) ;4th ICD CODE
- S:PSU5'["N" PSUID5=$P($$ICDDATA^ICDXCODE(CSYS(5),PSU5),U,2) D
- .I $D(PSUID5) S ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,5,PSUID5)=$G(PSU5("ICDSYS")) ;5th ICD CODE
- S:PSU6'["N" PSUID6=$P($$ICDDATA^ICDXCODE(CSYS(6),PSU6),U,2) D
- .I $D(PSUID6) S ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,6,PSUID6)=$G(PSU6("ICDSYS")) ;6th ICD CODE
- S:PSU7'["N" PSUID7=$P($$ICDDATA^ICDXCODE(CSYS(7),PSU7),U,2) D
- .I $D(PSUID7) S ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,7,PSUID7)=$G(PSU7("ICDSYS")) ;7th ICD CODE
- S:PSU8'["N" PSUID8=$P($$ICDDATA^ICDXCODE(CSYS(8),PSU8),U,2) D
- .I $D(PSUID8) S ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,8,PSUID8)=$G(PSU8("ICDSYS")) ;8th ICD CODE
- S:PSU9'["N" PSUID9=$P($$ICDDATA^ICDXCODE(CSYS(9),PSU9),U,2) D
- .I $D(PSUID9) S ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,9,PSUID9)=$G(PSU9("ICDSYS")) ;9th ICD CODE
- S:PSU10'["N" PSUID10=$P($$ICDDATA^ICDXCODE(CSYS(10),PSU10),U,2) D
- .I $D(PSUID10) S ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,10,PSUID10)=$G(PSU10("ICDSYS")) ;10th ICD CODE
- S:PSU11'["N" PSUID11=$P($$ICDDATA^ICDXCODE(CSYS(11),PSU11),U,2) D
- .I $D(PSUID11) S ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,11,PSUID11)=$G(PSU11("ICDSYS")) ;11th ICD CODE
- Q
- ;
- PTFM ;
- S PSUCD=0
- S I=12
- F S PSUCD=$O(^DGPT(PSUC,"M","AC",PSUCD)) Q:'PSUCD D
- .I PSUCD="" S PSUCD="N"
- .N PSUIDT
- .I PSUCD'="N" D
- ..S CSYS(I)=$$CSI^ICDEX(80,PSUCD),PSUIDT=$P(($$ICDDATA^ICDXCODE(CSYS(I),PSUCD)),U,2)
- ..S ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,I,PSUIDT)=$S(CSYS(I)=1:9,CSYS(I)=30:10,1:"")
- ..D DEL
- ..S I=I+1
- .Q
- Q
- ;
- DEL ;Delete duplicates
- ;
- F N=1:1:10 I $D(^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,N,PSUIDT)) D
- .K ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,I,PSUIDT)
- Q
- ;
- FIN ;$O through array, and set codes into the Inpatient Record
- ;global ^XTMP("PSU_"_PSUJOB,"PSUIPV", ISYSCODE and SYSCODE are the coding system values
- ;DRP 2/13/2012 ADDED SYSCODE LOGIC
- N SYSCODE,ISYSCODE
- S T=0,N=8
- F S T=$O(^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,T)) Q:'T Q:N=29 D
- .S PSUIDF=""
- .F S PSUIDF=$O(^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,T,PSUIDF)) Q:'(PSUIDF]"") D
- ..S SYSCODE=$G(^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,T,PSUIDF)) S:$G(ISYSCODE)="" ISYSCODE=SYSCODE
- ..S:SYSCODE'="" SYSCODE=$S(SYSCODE=ISYSCODE:SYSCODE,1:"U") ; Set to "U" if there has been a change
- ..I SYSCODE="U",ISYSCODE'="U" S ISYSCODE="U" ;
- ..S $P(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUC),U,N)=PSUIDF
- ..S N=N+1
- F N=8:1:28 I '($P(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUC),U,N)]"") D
- .S $P(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUC),U,N)="" ;Set unfilled pieces to null
- .Q
- K PSUCSYS1 S PSUCSYS1=$G(SYSCODE,"")
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSUDEM8 6396 printed Feb 18, 2025@23:53:52 Page 2
- PSUDEM8 ;BIR/DAM - ICD9 Codes for Inpatient PTF Record Extract ;20 DEC 2001
- +1 ;;4.0;PHARMACY BENEFITS MANAGEMENT;**19**;MARCH, 2005;Build 28
- +2 ;
- +3 ;DBIA's
- +4 ; Reference to file 45 supported by DBIA 3511
- +5 ; Reference to file 80 supported by DBIA 10082
- +6 ; Reference to ICDEX supported by DBIA 5747
- +7 ; Reference to ICDXCODE supported by DBIA 5699
- +8 ;
- EN ;EN CALLED FROM PSUDEM7
- +1 DO PTFIEN
- +2 QUIT
- +3 ;
- PTFIEN ;$O through ^XTMP("PSU_"_PSUJOB,"PSUIPV" to get all the PTF IEN's
- +1 ;
- +2 ;S PSUC=0
- +3 SET PSUC=0
- +4 FOR
- SET PSUC=$ORDER(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUC))
- if 'PSUC
- QUIT
- Begin DoDot:1
- +5 ;gather ICD9 data on ^DGPT(D0,70 node
- DO PTF70
- +6 ;gather ICD9 data on ^DGPT(D0,"M","AC" node
- DO PTFM
- +7 DO FIN
- KILL ^XTMP("PSU_"_PSUJOB,"PSUTMP3")
- +8 ;gather CPT data on 2 separate ^DGPT nodes
- DO EN^PSUDEM9
- End DoDot:1
- +9 QUIT
- +10 ;
- PTF70 ;Find all ICD pointers present on ^DGPT(D0,70 node
- +1 ;drp 2/13/2012 added second line to each line in old block
- +2 ;N PSU1,PSU2,PSU3,PSU4,PSU5,PSU6,PSU7,PSU8,PSU9,PSU10,PSU11
- +3 NEW PSU1,PSU2,PSU3,PSU4,PSU5,PSU6,PSU7,PSU8,PSU9,PSU10,PSU11,CSYS
- +4 ;
- +5 ;Ptr 1 PRINCIPAL[10P:80
- SET PSU1=$PIECE($GET(^DGPT(PSUC,70)),U,10)
- if PSU1=""
- SET PSU1="NULL"
- +6 if PSU1'="NULL"
- SET CSYS(1)=$$CSI^ICDEX(80,PSU1)
- SET PSU1("ICDSYS")=$SELECT(CSYS(1)=1:9,CSYS(1)=30:10,1:"")
- +7 ;
- +8 ;Ptr 2 SECONDARY[16P:80]
- SET PSU2=$PIECE($GET(^DGPT(PSUC,70)),U,16)
- if PSU2=""
- SET PSU2="NULL"
- +9 if PSU2'="NULL"
- SET CSYS(2)=$$CSI^ICDEX(80,PSU2)
- SET PSU2("ICDSYS")=$SELECT(CSYS(2)=1:9,CSYS(2)=30:10,1:"")
- +10 ;
- +11 ;Ptr 3
- SET PSU3=$PIECE($GET(^DGPT(PSUC,70)),U,17)
- if PSU3=""
- SET PSU3="NULL"
- +12 if PSU3'="NULL"
- SET CSYS(3)=$$CSI^ICDEX(80,PSU3)
- SET PSU3("ICDSYS")=$SELECT(CSYS(3)=1:9,CSYS(3)=30:10,1:"")
- +13 ;
- +14 ;Ptr 4
- SET PSU4=$PIECE($GET(^DGPT(PSUC,70)),U,18)
- if PSU4=""
- SET PSU4="NULL"
- +15 if PSU4'="NULL"
- SET CSYS(4)=$$CSI^ICDEX(80,PSU4)
- SET PSU4("ICDSYS")=$SELECT(CSYS(4)=1:9,CSYS(4)=30:10,1:"")
- +16 ;
- +17 ;Ptr 5
- SET PSU5=$PIECE($GET(^DGPT(PSUC,70)),U,19)
- if PSU5=""
- SET PSU5="NULL"
- +18 if PSU5'="NULL"
- SET CSYS(5)=$$CSI^ICDEX(80,PSU5)
- SET PSU5("ICDSYS")=$SELECT(CSYS(5)=1:9,CSYS(5)=30:10,1:"")
- +19 ;
- +20 ;Ptr 6
- SET PSU6=$PIECE($GET(^DGPT(PSUC,70)),U,20)
- if PSU6=""
- SET PSU6="NULL"
- +21 if PSU6'="NULL"
- SET CSYS(6)=$$CSI^ICDEX(80,PSU6)
- SET PSU6("ICDSYS")=$SELECT(CSYS(6)=1:9,CSYS(6)=30:10,1:"")
- +22 ;
- +23 ;Ptr 7
- SET PSU7=$PIECE($GET(^DGPT(PSUC,70)),U,21)
- if PSU7=""
- SET PSU7="NULL"
- +24 if PSU7'="NULL"
- SET CSYS(7)=$$CSI^ICDEX(80,PSU7)
- SET PSU7("ICDSYS")=$SELECT(CSYS(7)=1:9,CSYS(7)=30:10,1:"")
- +25 ;
- +26 ;Ptr 8
- SET PSU8=$PIECE($GET(^DGPT(PSUC,70)),U,22)
- if PSU8=""
- SET PSU8="NULL"
- +27 if PSU8'="NULL"
- SET CSYS(8)=$$CSI^ICDEX(80,PSU8)
- SET PSU8("ICDSYS")=$SELECT(CSYS(8)=1:9,CSYS(8)=30:10,1:"")
- +28 ;
- +29 ;Ptr 9
- SET PSU9=$PIECE($GET(^DGPT(PSUC,70)),U,23)
- if PSU9=""
- SET PSU9="NULL"
- +30 if PSU9'="NULL"
- SET CSYS(9)=$$CSI^ICDEX(80,PSU9)
- SET PSU9("ICDSYS")=$SELECT(CSYS(9)=1:9,CSYS(9)=30:10,1:"")
- +31 ;
- +32 ;Ptr 10
- SET PSU10=$PIECE($GET(^DGPT(PSUC,70)),U,24)
- if PSU10=""
- SET PSU10="NULL"
- +33 if PSU10'="NULL"
- SET CSYS(10)=$$CSI^ICDEX(80,PSU10)
- SET PSU10("ICDSYS")=$SELECT(CSYS(10)=1:9,CSYS(10)=30:10,1:"")
- +34 ;
- +35 ;Ptr 11 PRINCIPAL DIAGNOSIS pre 1986 [11P:80]
- SET PSU11=$PIECE($GET(^DGPT(PSUC,70)),U,11)
- if PSU11=""
- SET PSU11="NULL"
- +36 if PSU11'="NULL"
- SET CSYS(11)=$$CSI^ICDEX(80,PSU11)
- SET PSU11("ICDSYS")=$SELECT(CSYS(11)=1:9,CSYS(11)=30:10,1:"")
- +37 DO ICD91
- +38 QUIT
- +39 ;
- ICD91 ;Find ICD codes from pointer on ^DGPT(D0,70 node and place in
- +1 ;an array
- +2 ;
- +3 NEW PSUID1,PSUID2,PSUID3,PSUID4,PSUID5,PSUID6,PSUID7,PSUID8,PSUID9
- +4 NEW PSUID10,PSUID11
- +5 if PSU1'["N"
- SET PSUID1=$PIECE($$ICDDATA^ICDXCODE(CSYS(1),PSU1),U,2)
- Begin DoDot:1
- +6 ;1ST ICD CODE
- IF $DATA(PSUID1)
- SET ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,1,PSUID1)=$GET(PSU1("ICDSYS"))
- End DoDot:1
- +7 if PSU2'["N"
- SET PSUID2=$PIECE($$ICDDATA^ICDXCODE(CSYS(2),PSU2),U,2)
- Begin DoDot:1
- +8 ;2ND ICD CODE
- IF $DATA(PSUID2)
- SET ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,2,PSUID2)=$GET(PSU2("ICDSYS"))
- End DoDot:1
- +9 if PSU3'["N"
- SET PSUID3=$PIECE($$ICDDATA^ICDXCODE(CSYS(3),PSU3),U,2)
- Begin DoDot:1
- +10 ;3rd ICD CODE
- IF $DATA(PSUID3)
- SET ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,3,PSUID3)=$GET(PSU3("ICDSYS"))
- End DoDot:1
- +11 if PSU4'["N"
- SET PSUID4=$PIECE($$ICDDATA^ICDXCODE(CSYS(4),PSU4),U,2)
- Begin DoDot:1
- +12 ;4th ICD CODE
- IF $DATA(PSUID4)
- SET ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,4,PSUID4)=$GET(PSU4("ICDSYS"))
- End DoDot:1
- +13 if PSU5'["N"
- SET PSUID5=$PIECE($$ICDDATA^ICDXCODE(CSYS(5),PSU5),U,2)
- Begin DoDot:1
- +14 ;5th ICD CODE
- IF $DATA(PSUID5)
- SET ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,5,PSUID5)=$GET(PSU5("ICDSYS"))
- End DoDot:1
- +15 if PSU6'["N"
- SET PSUID6=$PIECE($$ICDDATA^ICDXCODE(CSYS(6),PSU6),U,2)
- Begin DoDot:1
- +16 ;6th ICD CODE
- IF $DATA(PSUID6)
- SET ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,6,PSUID6)=$GET(PSU6("ICDSYS"))
- End DoDot:1
- +17 if PSU7'["N"
- SET PSUID7=$PIECE($$ICDDATA^ICDXCODE(CSYS(7),PSU7),U,2)
- Begin DoDot:1
- +18 ;7th ICD CODE
- IF $DATA(PSUID7)
- SET ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,7,PSUID7)=$GET(PSU7("ICDSYS"))
- End DoDot:1
- +19 if PSU8'["N"
- SET PSUID8=$PIECE($$ICDDATA^ICDXCODE(CSYS(8),PSU8),U,2)
- Begin DoDot:1
- +20 ;8th ICD CODE
- IF $DATA(PSUID8)
- SET ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,8,PSUID8)=$GET(PSU8("ICDSYS"))
- End DoDot:1
- +21 if PSU9'["N"
- SET PSUID9=$PIECE($$ICDDATA^ICDXCODE(CSYS(9),PSU9),U,2)
- Begin DoDot:1
- +22 ;9th ICD CODE
- IF $DATA(PSUID9)
- SET ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,9,PSUID9)=$GET(PSU9("ICDSYS"))
- End DoDot:1
- +23 if PSU10'["N"
- SET PSUID10=$PIECE($$ICDDATA^ICDXCODE(CSYS(10),PSU10),U,2)
- Begin DoDot:1
- +24 ;10th ICD CODE
- IF $DATA(PSUID10)
- SET ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,10,PSUID10)=$GET(PSU10("ICDSYS"))
- End DoDot:1
- +25 if PSU11'["N"
- SET PSUID11=$PIECE($$ICDDATA^ICDXCODE(CSYS(11),PSU11),U,2)
- Begin DoDot:1
- +26 ;11th ICD CODE
- IF $DATA(PSUID11)
- SET ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,11,PSUID11)=$GET(PSU11("ICDSYS"))
- End DoDot:1
- +27 QUIT
- +28 ;
- PTFM ;
- +1 SET PSUCD=0
- +2 SET I=12
- +3 FOR
- SET PSUCD=$ORDER(^DGPT(PSUC,"M","AC",PSUCD))
- if 'PSUCD
- QUIT
- Begin DoDot:1
- +4 IF PSUCD=""
- SET PSUCD="N"
- +5 NEW PSUIDT
- +6 IF PSUCD'="N"
- Begin DoDot:2
- +7 SET CSYS(I)=$$CSI^ICDEX(80,PSUCD)
- SET PSUIDT=$PIECE(($$ICDDATA^ICDXCODE(CSYS(I),PSUCD)),U,2)
- +8 SET ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,I,PSUIDT)=$SELECT(CSYS(I)=1:9,CSYS(I)=30:10,1:"")
- +9 DO DEL
- +10 SET I=I+1
- End DoDot:2
- +11 QUIT
- End DoDot:1
- +12 QUIT
- +13 ;
- DEL ;Delete duplicates
- +1 ;
- +2 FOR N=1:1:10
- IF $DATA(^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,N,PSUIDT))
- Begin DoDot:1
- +3 KILL ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,I,PSUIDT)
- End DoDot:1
- +4 QUIT
- +5 ;
- FIN ;$O through array, and set codes into the Inpatient Record
- +1 ;global ^XTMP("PSU_"_PSUJOB,"PSUIPV", ISYSCODE and SYSCODE are the coding system values
- +2 ;DRP 2/13/2012 ADDED SYSCODE LOGIC
- +3 NEW SYSCODE,ISYSCODE
- +4 SET T=0
- SET N=8
- +5 FOR
- SET T=$ORDER(^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,T))
- if 'T
- QUIT
- if N=29
- QUIT
- Begin DoDot:1
- +6 SET PSUIDF=""
- +7 FOR
- SET PSUIDF=$ORDER(^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,T,PSUIDF))
- if '(PSUIDF]"")
- QUIT
- Begin DoDot:2
- +8 SET SYSCODE=$GET(^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,T,PSUIDF))
- if $GET(ISYSCODE)=""
- SET ISYSCODE=SYSCODE
- +9 ; Set to "U" if there has been a change
- if SYSCODE'=""
- SET SYSCODE=$SELECT(SYSCODE=ISYSCODE:SYSCODE,1:"U")
- +10 ;
- IF SYSCODE="U"
- IF ISYSCODE'="U"
- SET ISYSCODE="U"
- +11 SET $PIECE(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUC),U,N)=PSUIDF
- +12 SET N=N+1
- End DoDot:2
- End DoDot:1
- +13 FOR N=8:1:28
- IF '($PIECE(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUC),U,N)]"")
- Begin DoDot:1
- +14 ;Set unfilled pieces to null
- SET $PIECE(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUC),U,N)=""
- +15 QUIT
- End DoDot:1
- +16 KILL PSUCSYS1
- SET PSUCSYS1=$GET(SYSCODE,"")
- +17 QUIT
