- PSUUD6 ;BIR/DAM - UD AMIS Summary Message I;23 MAR 2004
- ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
- ;
- ;Reference to file #42.6 supported by DBIA 4597
- ;Reference to file #42.7 supported by DBIA 4598
- ;Reference to file #40.8 supported by DBIA 2438
- ;
- EN ;Entry point to construct globals for AMIS summary message
- ;Called from PSUUD3
- ;
- K UDAM ;array to hold tabulated data
- K SPEC ;array to hold specialty data
- ;
- S PSUDV=0
- F S PSUDV=$O(^XTMP(PSUUDSUB,"DIS",PSUDV)) Q:PSUDV="" D
- .D DISP
- .D RET
- .D TCOST
- .D NET
- .D AVG
- .D TRUNC
- .D SPEC
- .D DIVT
- .D GRAND
- ;
- D TOTAL
- ;
- Q
- ;
- DISP ;Add doses dispensed of all drugs for each division
- ;
- N DSP,A
- S DSP=^XTMP(PSUUDSUB,"DISP",PSUDV)
- S $P(UDAM(PSUDV),U,1)=DSP
- ;
- I $P(UDAM(PSUDV),U,1)["." D
- .S A=$F($P(UDAM(PSUDV),U,1),".") ;Find 1st position after decimal
- .S $P(UDAM(PSUDV),U,1)=$E($P(UDAM(PSUDV),U,1),1,(A-2)) ;Truncate
- ;
- Q
- ;
- RET ;Add doses returned of all drugs for each division
- ;
- N RET,A
- S RET=^XTMP(PSUUDSUB,"RET",PSUDV)
- S $P(UDAM(PSUDV),U,2)=RET
- ;
- I $P(UDAM(PSUDV),U,2)["." D
- .S A=$F($P(UDAM(PSUDV),U,2),".") ;Find 1st position after decimal
- .S $P(UDAM(PSUDV),U,2)=$E($P(UDAM(PSUDV),U,2),1,(A-2)) ;Truncate
- Q
- ;
- NET ;Calculate Net doses dispensed of all drugs
- ;
- S $P(UDAM(PSUDV),U,3)=$P(UDAM(PSUDV),U,1)-$P(UDAM(PSUDV),U,2)
- ;
- Q
- ;
- TCOST ;Find total cost per drug
- ;
- N CST,DP,RT,NT
- ;
- S CST=^XTMP(PSUUDSUB,"CST",PSUDV) ;Price per dispensed unit
- ;
- S $P(UDAM(PSUDV),U,4)=CST
- ;
- Q
- ;
- AVG ;Calculate average cost per dose
- ;
- N TCST,NET
- ;
- S NET=$P(UDAM(PSUDV),U,3) ;Net doses dispensed
- ;
- I $G(NET)'>0 S NET=1
- ;
- S TCST=$P(UDAM(PSUDV),U,4) ;Total cost
- ;
- S $P(UDAM(PSUDV),U,5)=$P($G(UDAM(PSUDV)),U,5)+(TCST/NET)
- ;
- Q
- ;
- TRUNC ;Truncate pieces with dollar values to 2 decimal places
- ;
- F I=4:1:5 D
- .N A,B,C
- .;
- .I $P(UDAM(PSUDV),U,I)'["." D Q
- ..S $P(UDAM(PSUDV),U,I)=$P(UDAM(PSUDV),U,4)_".00"
- .;
- .S A=$F($P(UDAM(PSUDV),U,I),".") ;Find 1st position after decimal
- .;
- .S B=$E($P(UDAM(PSUDV),U,I),1,(A-1)) ;Extract dollars and decimal
- .;
- .S C=$E($P(UDAM(PSUDV),U,I),A,(A+1)) ;Extract cents after decimal
- .;
- .I $L(C)'=2 S C=$E(C,1)_0
- .;
- .S $P(UDAM(PSUDV),U,I)=B_C
- ;
- M ^XTMP(PSUUDSUB,"DOSES",PSUDV)=UDAM(PSUDV)
- Q
- ;
- TOTAL ;Add dose totals of all divisions
- ;
- N DTOT,RTOT,NETOT,TCST,ACST
- ;
- S PSUD=0
- F S PSUD=$O(UDAM(PSUD)) Q:PSUD="" D
- .S DTOT=$G(DTOT)+$P(UDAM(PSUD),U,1) ;Total of doses dispensed
- .S RTOT=$G(RTOT)+$P(UDAM(PSUD),U,2) ;Total of returned doses
- .S NETOT=$G(NETOT)+$P(UDAM(PSUD),U,3) ;Total of net doses disp
- .S TCST=$G(TCST)+$P(UDAM(PSUD),U,4) ;Total of total cost
- .;S ACST=$G(ACST)+$P(UDAM(PSUD),U,5) ;Total of average cost
- .I $G(NETOT) S ACST=$G(TCST)/$G(NETOT) D
- ..I ACST'["." S ACST=ACST_".00" Q
- ..N A,B,C
- ..S A=$F(ACST,".") ;Find 1st position after decimal
- ..S B=$E(ACST,1,(A-1)) ;Extract dollars and decimal
- ..S C=$E(ACST,A,(A+1)) ;Extract cents after decimal
- ..I $L(C)'=2 S C=$E(C,1)_0
- ..S ACST=B_C
- ;
- S ^XTMP(PSUUDSUB,"DOSTOT")=DTOT_U_RTOT_U_NETOT_U_TCST_U_ACST
- ;
- Q
- ;
- SPEC ;Find out if a monthly extract is being run
- ;
- N PSUMT,PSUMTH
- I $D(PSUMON) D
- .S PSUMT=PSUMON_"00"
- .I $D(^DGAM(334,"B",PSUMT)) D SPEC1
- .;
- .S PSUMTH=PSUMT
- .I $D(^DGAM(345,"B",PSUMTH)) D SPEC2
- ;
- Q
- ;
- SPEC1 ;Find division names from File (#42.6) records within
- ;the month of the extract
- ;
- N PSUDNM
- ;
- M SPEC(334,PSUMT)=^DGAM(334,PSUMT) ;set node into array
- ;
- S PSUD1=0
- F S PSUD1=$O(SPEC(334,PSUMT,"SE",PSUD1)) Q:PSUD1="" D
- .S PSUD2=0
- .F S PSUD2=$O(SPEC(334,PSUMT,"SE",PSUD1,"D",PSUD2)) Q:PSUD2="" D
- ..;find division and match to DIVNM
- ..S X=PSUD2
- ..S PSUNM=$$VAL^PSUTL(40.8,X,.01)
- ..S X=PSUDV,DIC=40.8,DIC(0)="X",D="C" D IX^DIC
- ..S X=+Y S PSUDNM=$$VAL^PSUTL(40.8,X,.01)
- ..I PSUNM=PSUDNM D REC1
- Q
- ;
- REC1 ;Create a record of specialties and days of patient care for File #42.6
- ;for each division within the month of the extract
- ;
- N SPC,DAYA,DAYB,SPCE
- ;
- S SPC=$P(SPEC(334,PSUMT,"SE",PSUD1,0),U,1) ;Specialty code
- ;
- S DAYA=$P(SPEC(334,PSUMT,"SE",PSUD1,"D",PSUD2,0),U,12) ;Days of care
- ;
- S DAYB=$P(SPEC(334,PSUMT,"SE",PSUD1,"D",PSUD2,0),U,24) ;Days of care >45
- ;
- ;
- ;Find external form of specialty
- S:SPC=334 SPCE="PSYCHIATRY"
- S:SPC=335 SPCE="INTERMEDIATE"
- S:SPC=336 SPCE="MEDICINE"
- S:SPC=337 SPCE="NEUROLOGY"
- S:SPC=338 SPCE="REHAB MEDICINE"
- S:SPC=339 SPCE="BLIND REHAB"
- S:SPC=340 SPCE="SPINAL CORD INJURY"
- S:SPC=341 SPCE="SURGERY"
- ;
- S ^XTMP(PSUUDSUB,"SPEC",PSUDV,SPC)=SPCE_U_(DAYA+DAYB) ;Record created
- ;
- Q
- ;
- SPEC2 ;Find division names from File (#42.7) records within
- ;the month of the extract
- ;
- N PSUDNAM
- M SPEC(345,PSUMTH)=^DGAM(345,PSUMTH) ;set node into array
- ;
- S PSUD1=0
- F S PSUD1=$O(SPEC(345,PSUMTH,"SE",PSUD1)) Q:PSUD1="" D
- .S PSUD2=0
- .F S PSUD2=$O(SPEC(345,PSUMTH,"SE",PSUD1,"D",PSUD2)) Q:PSUD2="" D
- ..;find division and match to DIVNM
- ..S X=PSUD2
- ..S PSUNM=$$VAL^PSUTL(40.8,X,.01)
- ..S X=PSUDV,DIC=40.8,DIC(0)="X",D="C" D IX^DIC
- ..S X=+Y S PSUDNAM=$$VAL^PSUTL(40.8,X,.01)
- ..I PSUNM=PSUDNAM D REC2
- ;
- Q
- ;
- REC2 ;Create a record of specialties and days of patient care for File #42.7
- ;for each division within the month of the extract
- ;
- N SPC,DAY,SPCE
- ;
- S SPC=$P($G(SPEC(345,PSUMTH,"SE",PSUD1,0)),U,1) ;Specialty code
- ;
- S DAY=$P($G(SPEC(345,PSUMTH,"SE",PSUD1,"D",PSUD2,0)),U,16) ;Days of care
- ;
- ;Find external form of specialty
- S:SPC=345 SPCE="VA NURSING HOME"
- ;
- I $D(SPCE) D
- .S ^XTMP(PSUUDSUB,"SPEC",PSUDV,SPC)=SPCE_U_DAY ;Record created
- Q
- ;
- DIVT ;Calculate division totals
- ;
- N TOT
- S PSUSP=0
- F S PSUSP=$O(^XTMP(PSUUDSUB,"SPEC",PSUDV,PSUSP)) Q:PSUSP="" D
- .S TOT=$G(TOT)+$P(^XTMP(PSUUDSUB,"SPEC",PSUDV,PSUSP),U,2)
- .S ^XTMP(PSUUDSUB,"DIVTOT",PSUDV)=TOT
- Q
- ;
- GRAND ;Calculate grand total of all divisions
- ;
- ;
- S ^XTMP(PSUUDSUB,"GTOT")=$G(^XTMP(PSUUDSUB,"GTOT"))+$G(^XTMP(PSUUDSUB,"DIVTOT",PSUDV))
- ;
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSUUD6 6143 printed Feb 18, 2025@23:54:44 Page 2
- PSUUD6 ;BIR/DAM - UD AMIS Summary Message I;23 MAR 2004
- +1 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
- +2 ;
- +3 ;Reference to file #42.6 supported by DBIA 4597
- +4 ;Reference to file #42.7 supported by DBIA 4598
- +5 ;Reference to file #40.8 supported by DBIA 2438
- +6 ;
- EN ;Entry point to construct globals for AMIS summary message
- +1 ;Called from PSUUD3
- +2 ;
- +3 ;array to hold tabulated data
- KILL UDAM
- +4 ;array to hold specialty data
- KILL SPEC
- +5 ;
- +6 SET PSUDV=0
- +7 FOR
- SET PSUDV=$ORDER(^XTMP(PSUUDSUB,"DIS",PSUDV))
- if PSUDV=""
- QUIT
- Begin DoDot:1
- +8 DO DISP
- +9 DO RET
- +10 DO TCOST
- +11 DO NET
- +12 DO AVG
- +13 DO TRUNC
- +14 DO SPEC
- +15 DO DIVT
- +16 DO GRAND
- End DoDot:1
- +17 ;
- +18 DO TOTAL
- +19 ;
- +20 QUIT
- +21 ;
- DISP ;Add doses dispensed of all drugs for each division
- +1 ;
- +2 NEW DSP,A
- +3 SET DSP=^XTMP(PSUUDSUB,"DISP",PSUDV)
- +4 SET $PIECE(UDAM(PSUDV),U,1)=DSP
- +5 ;
- +6 IF $PIECE(UDAM(PSUDV),U,1)["."
- Begin DoDot:1
- +7 ;Find 1st position after decimal
- SET A=$FIND($PIECE(UDAM(PSUDV),U,1),".")
- +8 ;Truncate
- SET $PIECE(UDAM(PSUDV),U,1)=$EXTRACT($PIECE(UDAM(PSUDV),U,1),1,(A-2))
- End DoDot:1
- +9 ;
- +10 QUIT
- +11 ;
- RET ;Add doses returned of all drugs for each division
- +1 ;
- +2 NEW RET,A
- +3 SET RET=^XTMP(PSUUDSUB,"RET",PSUDV)
- +4 SET $PIECE(UDAM(PSUDV),U,2)=RET
- +5 ;
- +6 IF $PIECE(UDAM(PSUDV),U,2)["."
- Begin DoDot:1
- +7 ;Find 1st position after decimal
- SET A=$FIND($PIECE(UDAM(PSUDV),U,2),".")
- +8 ;Truncate
- SET $PIECE(UDAM(PSUDV),U,2)=$EXTRACT($PIECE(UDAM(PSUDV),U,2),1,(A-2))
- End DoDot:1
- +9 QUIT
- +10 ;
- NET ;Calculate Net doses dispensed of all drugs
- +1 ;
- +2 SET $PIECE(UDAM(PSUDV),U,3)=$PIECE(UDAM(PSUDV),U,1)-$PIECE(UDAM(PSUDV),U,2)
- +3 ;
- +4 QUIT
- +5 ;
- TCOST ;Find total cost per drug
- +1 ;
- +2 NEW CST,DP,RT,NT
- +3 ;
- +4 ;Price per dispensed unit
- SET CST=^XTMP(PSUUDSUB,"CST",PSUDV)
- +5 ;
- +6 SET $PIECE(UDAM(PSUDV),U,4)=CST
- +7 ;
- +8 QUIT
- +9 ;
- AVG ;Calculate average cost per dose
- +1 ;
- +2 NEW TCST,NET
- +3 ;
- +4 ;Net doses dispensed
- SET NET=$PIECE(UDAM(PSUDV),U,3)
- +5 ;
- +6 IF $GET(NET)'>0
- SET NET=1
- +7 ;
- +8 ;Total cost
- SET TCST=$PIECE(UDAM(PSUDV),U,4)
- +9 ;
- +10 SET $PIECE(UDAM(PSUDV),U,5)=$PIECE($GET(UDAM(PSUDV)),U,5)+(TCST/NET)
- +11 ;
- +12 QUIT
- +13 ;
- TRUNC ;Truncate pieces with dollar values to 2 decimal places
- +1 ;
- +2 FOR I=4:1:5
- Begin DoDot:1
- +3 NEW A,B,C
- +4 ;
- +5 IF $PIECE(UDAM(PSUDV),U,I)'["."
- Begin DoDot:2
- +6 SET $PIECE(UDAM(PSUDV),U,I)=$PIECE(UDAM(PSUDV),U,4)_".00"
- End DoDot:2
- QUIT
- +7 ;
- +8 ;Find 1st position after decimal
- SET A=$FIND($PIECE(UDAM(PSUDV),U,I),".")
- +9 ;
- +10 ;Extract dollars and decimal
- SET B=$EXTRACT($PIECE(UDAM(PSUDV),U,I),1,(A-1))
- +11 ;
- +12 ;Extract cents after decimal
- SET C=$EXTRACT($PIECE(UDAM(PSUDV),U,I),A,(A+1))
- +13 ;
- +14 IF $LENGTH(C)'=2
- SET C=$EXTRACT(C,1)_0
- +15 ;
- +16 SET $PIECE(UDAM(PSUDV),U,I)=B_C
- End DoDot:1
- +17 ;
- +18 MERGE ^XTMP(PSUUDSUB,"DOSES",PSUDV)=UDAM(PSUDV)
- +19 QUIT
- +20 ;
- TOTAL ;Add dose totals of all divisions
- +1 ;
- +2 NEW DTOT,RTOT,NETOT,TCST,ACST
- +3 ;
- +4 SET PSUD=0
- +5 FOR
- SET PSUD=$ORDER(UDAM(PSUD))
- if PSUD=""
- QUIT
- Begin DoDot:1
- +6 ;Total of doses dispensed
- SET DTOT=$GET(DTOT)+$PIECE(UDAM(PSUD),U,1)
- +7 ;Total of returned doses
- SET RTOT=$GET(RTOT)+$PIECE(UDAM(PSUD),U,2)
- +8 ;Total of net doses disp
- SET NETOT=$GET(NETOT)+$PIECE(UDAM(PSUD),U,3)
- +9 ;Total of total cost
- SET TCST=$GET(TCST)+$PIECE(UDAM(PSUD),U,4)
- +10 ;S ACST=$G(ACST)+$P(UDAM(PSUD),U,5) ;Total of average cost
- +11 IF $GET(NETOT)
- SET ACST=$GET(TCST)/$GET(NETOT)
- Begin DoDot:2
- +12 IF ACST'["."
- SET ACST=ACST_".00"
- QUIT
- +13 NEW A,B,C
- +14 ;Find 1st position after decimal
- SET A=$FIND(ACST,".")
- +15 ;Extract dollars and decimal
- SET B=$EXTRACT(ACST,1,(A-1))
- +16 ;Extract cents after decimal
- SET C=$EXTRACT(ACST,A,(A+1))
- +17 IF $LENGTH(C)'=2
- SET C=$EXTRACT(C,1)_0
- +18 SET ACST=B_C
- End DoDot:2
- End DoDot:1
- +19 ;
- +20 SET ^XTMP(PSUUDSUB,"DOSTOT")=DTOT_U_RTOT_U_NETOT_U_TCST_U_ACST
- +21 ;
- +22 QUIT
- +23 ;
- SPEC ;Find out if a monthly extract is being run
- +1 ;
- +2 NEW PSUMT,PSUMTH
- +3 IF $DATA(PSUMON)
- Begin DoDot:1
- +4 SET PSUMT=PSUMON_"00"
- +5 IF $DATA(^DGAM(334,"B",PSUMT))
- DO SPEC1
- +6 ;
- +7 SET PSUMTH=PSUMT
- +8 IF $DATA(^DGAM(345,"B",PSUMTH))
- DO SPEC2
- End DoDot:1
- +9 ;
- +10 QUIT
- +11 ;
- SPEC1 ;Find division names from File (#42.6) records within
- +1 ;the month of the extract
- +2 ;
- +3 NEW PSUDNM
- +4 ;
- +5 ;set node into array
- MERGE SPEC(334,PSUMT)=^DGAM(334,PSUMT)
- +6 ;
- +7 SET PSUD1=0
- +8 FOR
- SET PSUD1=$ORDER(SPEC(334,PSUMT,"SE",PSUD1))
- if PSUD1=""
- QUIT
- Begin DoDot:1
- +9 SET PSUD2=0
- +10 FOR
- SET PSUD2=$ORDER(SPEC(334,PSUMT,"SE",PSUD1,"D",PSUD2))
- if PSUD2=""
- QUIT
- Begin DoDot:2
- +11 ;find division and match to DIVNM
- +12 SET X=PSUD2
- +13 SET PSUNM=$$VAL^PSUTL(40.8,X,.01)
- +14 SET X=PSUDV
- SET DIC=40.8
- SET DIC(0)="X"
- SET D="C"
- DO IX^DIC
- +15 SET X=+Y
- SET PSUDNM=$$VAL^PSUTL(40.8,X,.01)
- +16 IF PSUNM=PSUDNM
- DO REC1
- End DoDot:2
- End DoDot:1
- +17 QUIT
- +18 ;
- REC1 ;Create a record of specialties and days of patient care for File #42.6
- +1 ;for each division within the month of the extract
- +2 ;
- +3 NEW SPC,DAYA,DAYB,SPCE
- +4 ;
- +5 ;Specialty code
- SET SPC=$PIECE(SPEC(334,PSUMT,"SE",PSUD1,0),U,1)
- +6 ;
- +7 ;Days of care
- SET DAYA=$PIECE(SPEC(334,PSUMT,"SE",PSUD1,"D",PSUD2,0),U,12)
- +8 ;
- +9 ;Days of care >45
- SET DAYB=$PIECE(SPEC(334,PSUMT,"SE",PSUD1,"D",PSUD2,0),U,24)
- +10 ;
- +11 ;
- +12 ;Find external form of specialty
- +13 if SPC=334
- SET SPCE="PSYCHIATRY"
- +14 if SPC=335
- SET SPCE="INTERMEDIATE"
- +15 if SPC=336
- SET SPCE="MEDICINE"
- +16 if SPC=337
- SET SPCE="NEUROLOGY"
- +17 if SPC=338
- SET SPCE="REHAB MEDICINE"
- +18 if SPC=339
- SET SPCE="BLIND REHAB"
- +19 if SPC=340
- SET SPCE="SPINAL CORD INJURY"
- +20 if SPC=341
- SET SPCE="SURGERY"
- +21 ;
- +22 ;Record created
- SET ^XTMP(PSUUDSUB,"SPEC",PSUDV,SPC)=SPCE_U_(DAYA+DAYB)
- +23 ;
- +24 QUIT
- +25 ;
- SPEC2 ;Find division names from File (#42.7) records within
- +1 ;the month of the extract
- +2 ;
- +3 NEW PSUDNAM
- +4 ;set node into array
- MERGE SPEC(345,PSUMTH)=^DGAM(345,PSUMTH)
- +5 ;
- +6 SET PSUD1=0
- +7 FOR
- SET PSUD1=$ORDER(SPEC(345,PSUMTH,"SE",PSUD1))
- if PSUD1=""
- QUIT
- Begin DoDot:1
- +8 SET PSUD2=0
- +9 FOR
- SET PSUD2=$ORDER(SPEC(345,PSUMTH,"SE",PSUD1,"D",PSUD2))
- if PSUD2=""
- QUIT
- Begin DoDot:2
- +10 ;find division and match to DIVNM
- +11 SET X=PSUD2
- +12 SET PSUNM=$$VAL^PSUTL(40.8,X,.01)
- +13 SET X=PSUDV
- SET DIC=40.8
- SET DIC(0)="X"
- SET D="C"
- DO IX^DIC
- +14 SET X=+Y
- SET PSUDNAM=$$VAL^PSUTL(40.8,X,.01)
- +15 IF PSUNM=PSUDNAM
- DO REC2
- End DoDot:2
- End DoDot:1
- +16 ;
- +17 QUIT
- +18 ;
- REC2 ;Create a record of specialties and days of patient care for File #42.7
- +1 ;for each division within the month of the extract
- +2 ;
- +3 NEW SPC,DAY,SPCE
- +4 ;
- +5 ;Specialty code
- SET SPC=$PIECE($GET(SPEC(345,PSUMTH,"SE",PSUD1,0)),U,1)
- +6 ;
- +7 ;Days of care
- SET DAY=$PIECE($GET(SPEC(345,PSUMTH,"SE",PSUD1,"D",PSUD2,0)),U,16)
- +8 ;
- +9 ;Find external form of specialty
- +10 if SPC=345
- SET SPCE="VA NURSING HOME"
- +11 ;
- +12 IF $DATA(SPCE)
- Begin DoDot:1
- +13 ;Record created
- SET ^XTMP(PSUUDSUB,"SPEC",PSUDV,SPC)=SPCE_U_DAY
- End DoDot:1
- +14 QUIT
- +15 ;
- DIVT ;Calculate division totals
- +1 ;
- +2 NEW TOT
- +3 SET PSUSP=0
- +4 FOR
- SET PSUSP=$ORDER(^XTMP(PSUUDSUB,"SPEC",PSUDV,PSUSP))
- if PSUSP=""
- QUIT
- Begin DoDot:1
- +5 SET TOT=$GET(TOT)+$PIECE(^XTMP(PSUUDSUB,"SPEC",PSUDV,PSUSP),U,2)
- +6 SET ^XTMP(PSUUDSUB,"DIVTOT",PSUDV)=TOT
- End DoDot:1
- +7 QUIT
- +8 ;
- GRAND ;Calculate grand total of all divisions
- +1 ;
- +2 ;
- +3 SET ^XTMP(PSUUDSUB,"GTOT")=$GET(^XTMP(PSUUDSUB,"GTOT"))+$GET(^XTMP(PSUUDSUB,"DIVTOT",PSUDV))
- +4 ;
- +5 QUIT
